perm filename CYCOMG.LSP[4,LMM] blob sn#037469 filedate 1973-05-06 generic text, type T, neo UTF8

(DEFPROP CYCOMGFNS
 (CYCOMGFNS LLUNCLASS
	    PERMRADS
	    LABEEDGES
	    LABELFV
	    STRUCTURESWITHATOMS
	    ATTACHFVS
	    ATTACHBIVALENTS
	    LLABELNODES
	    MAKEUNCLASSED)
VALUE)

(DEFPROP LLUNCLASS
 (LAMBDA (LLOBJ) (MAPCAR (QUOTE LUNCLASS) LLOBJ))
EXPR)

(DEFPROP PERMRADS
 (LAMBDA(CENT CLRADS FLAG)
  (PROG2 (SETQ CLRADS (CLCREATE CLRADS))
	 (IF (ATOM CENT)
	     THEN
	     (LIST (RADICAL CENTER = CENT ATTACHEDRADS = CLRADS))
	     ELSEIF
	     (STRUCFORM? CENT)
	     THEN
	     (LIST (RADICAL CENTER = (MAKECENTER RADSTRUC = CENT) ATTACHEDRADS = CLRADS))
	     ELSE
	     (FOR NEW
		  L
		  IN
		  (LABELFV CENT ((LAMBDA (X) (IF FLAG THEN (CONS 1. X) ELSE X)) (CDRLIST CLRADS)))
		  XLIST
		  (RADICAL CENTER
			   =
			   (MAKECENTER AFFLINK
				       =
				       (IF FLAG THEN (CAAR (LABELED L)) ELSE NIL)
				       RADSTRUC
				       =
				       (LSTRUC L)
				       CUFFLINKS
				       =
				       (IF FLAG THEN (CDR (LABELED L)) ELSE (LABELED L)))
			   ATTACHEDRADS
			   =
			   CLRADS)))))
EXPR)

(DEFPROP LABEEDGES
 (LAMBDA(STRUC LABELS)
  (FOR NEW
       L
       IN
       (LABELM (UNCLASSED OBJECTS
			  =
			  (FOR NEW
			       CT
			       IN
			       (CTABLE STRUC)
			       FOR
			       NEW
			       N
			       IN
			       (NBRS CT)
			       WHEN
			       (LEQ (NODENUM CT) N)
			       XLIST
			       (CONS (NODENUM CT) N)))
	       LABELS
	       STRUC)
       XLIST
       (LABELING FROM L LABELED = (LUNCLASS **))))
EXPR)

(DEFPROP LABELFV
 (LAMBDA(STRUC LABELS)
  (FOR NEW
       L
       IN
       (LABELM (UNCLASSED OBJECTS = (COLLECTFV STRUC)) LABELS STRUC)
       XLIST
       (LABELING FROM L LABELED = (LUNCLASS **))))
EXPR)

(DEFPROP STRUCTURESWITHATOMS
 (LAMBDA(CLL STRUC)
  (FOR NEW
       L
       IN
       (LLABELNODES STRUC (LCDRLIST CLL))
       XLIST
       (INSERTMARKERS (COPYSTRUC (LSTRUC L)) CLL (LABELED L))))
EXPR)

(DEFPROP ATTACHFVS
 (LAMBDA (FVP STRUC) (FOR NEW L IN (LLABELNODES STRUC FVP) XLIST (PUTFVS (COPYSTRUC (LSTRUC L)) (LABELED L))))
EXPR)

(DEFPROP ATTACHBIVALENTS
 (LAMBDA(PART STRUC)
  (FOR NEW
       L
       IN
       (LABELEDGES STRUC (CDRLIST PART))
       XLIST
       (PUTBIVS (COPYSTRUC (LSTRUC L)) (CARLIST PART) (LABELED L))))
EXPR)

(DEFPROP LLABELNODES
 (LAMBDA(STRUC LLABELS)
  (FOR NEW
       L
       IN
       (LLABEL (MAPCAR (QUOTE MAKEUNCLASSED) (LISTBYVALENCE STRUC)) LLABELS STRUC)
       XLIST
       (LABELING FROM L LABELED = (LLUNCLASS **))))
EXPR)

(DEFPROP MAKEUNCLASSED
 (LAMBDA (X) (IF (NOT X) THEN NIL ELSE (UNCLASSED OBJECTS = X)))
EXPR)